Technotools/Technotools (Chestnut CD-ROM)(1993).ISO/misc_pto/belfor/forms.m

Text File | 1988-09-27 | 32KB | 1,080 lines

;/************************************************************************
;**
;**        FILE NAME:   forms.m
;**
;**      DESCRIPTION:   forms insertion package for BRIEF
;**
;**  PUBLIC ROUTINES:   forms
;**
;**       CREATED BY:   Greg Belfor, R Software.
;**                     3520 N. 63rd Place
;**                     Scottsdale, AZ  85251
;**                     27-Sep-88
;**
;************************************************************************/

#define  TAB               0x09  ;** tab
#define  ESCAPE            0x1b  ;** esc
#define  EDIT_FORMS        0x3d  ;** "=", EDIT THE FORMS FILE character
#define  ADD_MARKED_AREA   0x2b  ;** "+", ADD MARKED AREA character
#define  NO_KEY            0x0   ;** no key typed
#define  SAVE              0
#define  RESTORE           1
#define  DELETE_SOURCE     0     ;** Change to 1 to delete the forms
                                 ;** buffer after each use.
                                 ;** Otherwise, the source remains resident
                                 ;** to speed up processing.

#include "dialog.h"
#include "equates.mh"

(extern  display_help)

(macro _init
   (
        (int
         _fforms_source_buffer
         _fforms_work_buffer
         _fforms_target_buffer
         _fforms_scrap_save
         _fforms_scrap_type
         _fforms_scrap_nl
         _fforms_pause_save
         )
      (string
         _fforms_ext
         _fforms_file
         )
      (global
         _fforms_target_buffer
         _fforms_work_buffer
         _fforms_ext
         _fforms_source_buffer
         _fforms_scrap_save
         _fforms_scrap_type
         _fforms_scrap_nl
         _fforms_pause_save
         _fforms_file
         )

      (= _fforms_source_buffer 0)   ;** give this an initial value
      (= _fforms_file (inq_environment "BFORMS"))
      (if (== _fforms_file "")
         (
            (= _fforms_file (+ (inq_environment "BPATH") "\\forms."))
         )
      )
      (= _fforms_file (_fslash_to_bslash (lower _fforms_file)))
   )
)

;*************************************** AUTHOR:  G. Belfor *************
;**
;** ROUTINE NAME: forms
;**    ARGUMENTS: id (if desired...)
;**
;**  DESCRIPTION: mainline macro for forms package
;**
;**      RETURNS: none
;**        NOTES: best if assigned to a key (of course)
;**
;***********************************************************************
(macro forms
   (
        (int     id col line found )
      (string  id_string searcher option )
      (extern  _ffmenu_buffer)

      (= _fforms_pause_save (pause_on_error 1))
        (= _fforms_target_buffer (inq_buffer))
;**
;**     read forms file into system buffer...only if it's not already
;**     there.
;**
      (if (== _fforms_source_buffer 0)
         (
              (= _fforms_source_buffer (create_buffer "_FORMS_" NULL SYSTEM))
            (set_buffer _fforms_source_buffer)
            (read_file _fforms_file)
            (set_buffer _fforms_target_buffer)
         )
      )
      (inq_names NULL _fforms_ext)
      (if (get_parm 0 id_string)
         (= id (atoi id_string 0))
      ;else
         (= id (_get_forms_id))
      )
      (switch id
         EDIT_FORMS
            (
               (_ff_cleanup)
               (edit_file _fforms_file)
               (return)
            )
         ADD_MARKED_AREA
            (
               (_forms_add)
               (_ff_cleanup)
               (return)
            )
         NO_KEY
            (
               (_ff_cleanup)
               (message "Illegal ID, forms aborted.")
               (return)
            )
         ESCAPE
            (
               (_ff_cleanup)
               (message "Forms aborted.")
               (return)
            )
         ;default
         ;NULL ()
      )
      (= found (_find_form id))
      (if (> found 0)
         (
            (_scrap_mgmt SAVE)
            (if (_move_to_working_buffer)
               (
                  (_substitute_symbols)
                  (= option (_get_option "align"))
                  (switch (lower option)
                     "left"
                           (_insert_left)
                     "cursor_indent"
                           (_insert_c_indent)
                     "column_paste"
                           (_insert_c_paste)
                     ;default
                     NULL
                        (
                           (error "Bad align type '%s', left assumed" option)
                           (_insert_left)
                        )
                  )
                  (set_buffer _fforms_target_buffer)
                  (delete_buffer _fforms_work_buffer)
                  (_scrap_mgmt RESTORE)
                  (message "Form '%c' inserted." id)
               )
            )
         )
      ;else
         (message "'%c' is not defined in %s." id _fforms_file)
      )
      (_ff_cleanup)
      (return)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _insert_left
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: inserts forms text at the left margin.
;**
;**      RETURNS: YES if successful, NO if not
;**        NOTES:
;**
;***********************************************************************
(macro _insert_left
   (
      (int  obuffer)

      (set_buffer _fforms_work_buffer)
      (top_of_buffer)
      (drop_anchor LINE_MARK)
      (end_of_buffer)
      (up)
      (copy)
      (set_buffer _fforms_target_buffer)
      (beginning_of_line)
      (drop_anchor NI_MARK)
      (paste)
      (if (search_fwd "~" REGXPR_OFF CASE_INSENSITIVE BLOCK_SEARCH)
         (
            (insert " ")
            (delete_char)
            (left)
         )
      )
      (raise_anchor)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _insert_c_indent
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: inserts forms text at the cursor column.
;**               The current buffer should contain the form
;**               The current position is the "options" line
;**               The form must end with a line containing !end
;**
;**      RETURNS: YES if successful, NO if not
;**        NOTES:
;**
;***********************************************************************
(macro _insert_c_indent
   (
      (int     scol)
      (string  indent1 indent2)

      (set_buffer _fforms_target_buffer)
      (inq_position NULL scol)
      (if (!= scol 1)
         (
            (set_buffer _fforms_work_buffer)
            (top_of_buffer)
            (sprintf indent1 "%%%ds" (-- scol))
            (sprintf indent2 indent1 " ")
            (translate "<" indent2 TRANS_GLOBAL REGXPR_ON)
         )
      )
      (_insert_left)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _insert_c_paste
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: inserts forms text like a "column paste"
;**
;**      RETURNS: none
;**        NOTES: This works by grabbing the work buffer with a line
;**               mark, then calling the _col_paste routine to do
;**               the work
;**
;***********************************************************************
(macro _insert_c_paste
   (
      (extern  _col_paste)

      (set_buffer _fforms_work_buffer)
      (top_of_buffer)
      (drop_anchor LINE_MARK)
      (end_of_buffer)
      (up)
      (copy)
      (set_buffer _fforms_target_buffer)
      (drop_anchor NI_MARK)
      (_col_paste)
      (if (search_fwd "~" REGXPR_OFF CASE_SENSITIVE BLOCK_SEARCH)
         (
            (insert " ")
            (delete_char)
            (left)
         )
      )
      (raise_anchor)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _substitute_symbols
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: performs substitution of environment variables as
;**               well as forms-specific variables on the forms_work_buffer
;**               Environment variables are of the form %name%.
;**               Forms-specific variables are of the form ^name^
;**
;**      RETURNS: none
;**        NOTES:
;**
;***********************************************************************
(macro _substitute_symbols
    (
      (int     var_len exp_len s_start s_len)
        (string    filename basename fname s_line s_var expansion line_end)

      (set_buffer _fforms_work_buffer)
;**
;**     expand environment variables of the form %variable%
;**
      (while 1
         (
            (top_of_buffer)
            (if (= var_len (search_fwd "\\%*\\%" REGXPR_ON))
               (
                  (-- var_len)
                  (beginning_of_line)
                  (= s_line (read))
                  (delete_to_eol)
                  (= s_start (search_string "\\%*\\%" s_line s_len))
                  (= line_end (substr s_line (+ s_start s_len)))
                  (= s_var (ltrim (trim (substr s_line (+ s_start 1) (- s_len 2) ))))
                  (= expansion (inq_environment (upper s_var)))
                  (= exp_len (strlen expansion))
                  (if (&& exp_len (strlen line_end))
                     (
                        (while (< exp_len var_len)
                           (
                              (+= expansion " ")
                              (++ exp_len)
                           )
                        )
                     )
                  )
                  (insert
                     (+ (substr s_line 1 (- s_start 1))
                        (+ expansion line_end)
                     )
                  )
                  (delete_char)
               )
            ;else
               (break)
            )
         )
      )
;**
;**     expand internal symbols of the form ^variable^
;**
      (while 1
         (
            (top_of_buffer)
            (if (= var_len (search_fwd "\\^*\\^" REGXPR_ON))
               (
                  (-- var_len)
                  (beginning_of_line)
                  (= s_line (read))
                  (delete_to_eol)
                  (= s_start (search_string "\\^*\\^" s_line s_len))
                  (= s_var (trim (substr s_line (+ s_start 1) (- s_len 2) )))
                  (switch (upper s_var)
                     "FILENAME"
                        (
                           (set_buffer _fforms_target_buffer)
                           (inq_names NULL NULL expansion)
                           (set_buffer _fforms_work_buffer)
                        )
                     "DATE"
                        (
                             (int        day  year )
                             (string    month weekday)
                             (date year NULL day month weekday)
                             (sprintf expansion "%3.3s %d " weekday day)
                           (sprintf weekday   "%3.3s %d"  month year)
                           (+= expansion weekday)
                        )
                     "CURSOR_WORD"
                        (
                           (= expansion (_get_cursor_word))
                        )
                     "CURSOR_LINE"
                        (
                           (save_position)
                           (beginning_of_line)
                           (= expansion (trim (read)))
                           (restore_position)
                        )
                     "CURSOR_TO_EOL"
                        (
                           (= expansion (trim (read)))
                        )
                  )
                  (= exp_len (strlen expansion))
                  (= line_end (substr s_line (+ s_start s_len)))
                  (if (&& exp_len (strlen line_end))
                     (
                        (while (< exp_len var_len)
                           (
                              (+= expansion " ")
                              (++ exp_len)
                           )
                        )
                     )
                  )
                  (insert
                     (+ (substr s_line 1 (- s_start 1))
                        (+ expansion line_end)
                     )
                  )
                  (delete_char)
               )
            ;else
               (break)
            )
         )
      )
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _forms_menu
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: Pop-up menu (using BRIEF dialog manager) for display
;**               and selection of forms.  On return, the keyboard buffer
;**               contains the character ID of the form.
;**
;**      RETURNS: none (keyboard buffer contains form ID)
;**        NOTES:
;**
;***********************************************************************
(macro _forms_menu
   (
      (int     key_length _ffmenu_buffer menu_height )
      (string  name align searcher key key_name forms_name
               forms_align line _fforms_response)
      (global  _ffmenu_buffer _fforms_response)

;**
;**     get extension and character identifier for search
;**
      (sprintf searcher "!?.{%s}|{\\*}[ \t\n*]+" _fforms_ext)
;**
;**     set up pre-defined keys in menu,
;**     use tabs for menu format control
;**
          (= _ffmenu_buffer (create_buffer "Select Form" NULL SYSTEM))
      (set_buffer _ffmenu_buffer)
      (top_of_buffer)
      (tabs 3 7 40 50)
      (insert "\tID\tForm Name\tAlign\n\t==\t=========\t=====")
      (insert "\n\t=:\tEdit the Forms file\t")
      (insert "\n\t+:\tAdd marked area as a form\t")
;**
;**     first search the forms_buffer for all defined forms.
;**     as each is found, insert the "letter: name align" in the
;**     __forms_menu buffer.
;**
;**     go to top of forms buffer, search (case insensitive) for identifier
;**
      (set_buffer _fforms_source_buffer)
      (top_of_buffer)
      (= key_length 1)
      (while 1
         (
            (if (= key_length (search_fwd searcher REGXPR_ON CASE_INSENSITIVE))
               (
                  (right)
                  (= key_name (read (- key_length 2)))
                  (= key (read 1))
                  (end_of_line)
                  (= forms_name (_get_option "name"))
                  (= forms_align (_get_option "align"))
                  (if (== forms_name "")
                     (= forms_name "?????")
                  )
                  (= line
                     (+ "\n\t"
                        (+ key
                           (+ ":\t"
                              (+ forms_name
                                 (+ "\t" forms_align)
                              )
                           )
                        )
                     )
                  )
                  (set_buffer _ffmenu_buffer)
                  (insert line)
                  (set_buffer _fforms_source_buffer)
               )
            ;else
               (break)
            )
         )
      )
      (inq_screen_size menu_height)
      (-= menu_height 7)
      (= _fforms_response "")            ;** default response is ESC
      (_process_menu 5 menu_height 59 3
                     "forms" "Press Enter to accept, ESC to abort" NULL
                     _ffmenu_buffer "__forms_menu" FAST)
      (push_back (atoi (substr _fforms_response 1 1) 0))
      (set_buffer _fforms_target_buffer)
      (delete_buffer _ffmenu_buffer)
   )
)


;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: __forms_menu
;**    ARGUMENTS: see dialog manager interface
;**
;**  DESCRIPTION: action macro for _forms_menu.  just sets the global
;**               _fforms_response to the menu item selected
;**
;**      RETURNS: TRUE
;**        NOTES: called by _forms_menu via dialog manager
;**
;***********************************************************************
(macro __forms_menu
   (
      (int  event_type line_no retval )

      (get_parm 0 event_type)
      (returns TRUE)

      (switch  event_type
         DIALOG_PICK_MENU
            (
               (get_parm 2 _fforms_response)
               (_dialog_esc)
            )
         DIALOG_MOVE_MENU
            (
               (get_parm 1 line_no)
               (switch line_no
                  1 (returns FALSE)
                  2 (returns FALSE)
                  ;default
                  NULL
               )
            )
         ;default
         ;NULL
      )
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _forms_add
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: adds a marked block as a form in the forms file.
;**               Uses the BRIEF dialog manager to present a dialog
;**               box for filling in options and ID.
;**
;**      RETURNS: none
;**        NOTES:
;**
;***********************************************************************
(macro _forms_add
   (
      (int     mark_type sline scol eline ecol _form_add_buffer
               key_length _aforms_buffer _search_buff )
      (string  new_form_id new_form_name new_form_align _pform searcher)
      (global  new_form_id new_form_name new_form_align _pform )

      (set_buffer _fforms_target_buffer)
      (= mark_type (inq_marked sline scol eline ecol))
      (if (== mark_type 0)
         (
            (error "Forms aborted: you must mark a block to add it.")
            (return)
         )
      )
          (= _aforms_buffer (create_buffer "F_AddMenu" NULL SYSTEM))
;**
;**     get list of already used IDs
;**
      (set_buffer _aforms_buffer)
      (insert "text (1,1) = \"    ID Character: \"\n")
      (insert "nonblank(1,20) = \"\"\n")
      (insert "text (2,1) = \"    Name of FORM: \"\n")
      (insert "string(2,20) = \"\"\n")
      (insert "text (3,1) = \"       Alignment: \"\n")
      (if (== COL_MARK mark_type)
         (insert "list(3,20) = \" left\tat_cursor(column_paste)\"\n")
      ;else
         (insert "list(3,20) = \"(left)at_cursor\tcolumn_paste\"\n")
      )
      (insert "text (5,1) = \"      IDs in use: \"\n")
      (end_of_buffer)
      (insert "\ntext(5,20) = \"")
;**
;**     now get all the IDs already in use and put them in the menu too
;**
      (sprintf searcher "!?.{%s}|{\\*}[ \t\n*]+" _fforms_ext)
      (set_buffer _fforms_source_buffer)
      (top_of_buffer)
      (= _pform "")
      (while 1
         (
            (if (search_fwd searcher REGXPR_ON CASE_INSENSITIVE)
               (
                  (right)
                  (= _pform (+ _pform (read 1)))
               )
            ;else
               (
                  (set_buffer _aforms_buffer)
                  (end_of_buffer)
                  (insert _pform)
                  (insert "\"\n")
                  (break)
               )
            )
         )
      )
;**
;**     process the dialog
;**
      (set_buffer _fforms_target_buffer)
      (_process_dialog_box 2 12 77 2
         "Add Form" "ID should be 1 character. Press ESC to Abort"
         NULL _aforms_buffer "__forms_add"
      )
      (delete_buffer _aforms_buffer)
;**
;**     if the new_form_id is "", then the form was aborted...
;**
      (if (== new_form_id "")
         (
            (message "Form addition aborted.")
            (return)
         )
      )
;**
;**     otherwise, get the marked area size,
;**     construct name and align parameters
;**     transfer stuff into form
;**
      (set_buffer _fforms_target_buffer)
      (if (!= new_form_name "")
         (= new_form_name (+ " !name: " new_form_name))
      )
      (= new_form_align (+ " !align: " new_form_align))
;**
;**     put the form in the forms buffer
;**
      (set_buffer _fforms_source_buffer)
      (end_of_buffer)
      (insert
         (+ "\n\n!"
            (+ new_form_id
               (+ "."
                  (+ _fforms_ext
                     (+ new_form_name
                        (+ new_form_align "\n")
                     )
                  )
               )
            )
         )
      )
      (transfer _fforms_target_buffer sline scol eline ecol)
      (insert "\n!end\n")
      (top_of_buffer)
      (drop_anchor LINE_MARK)
      (end_of_buffer)
      (write_block _fforms_file)
      (message (+ "New form created: " new_form_id))
      (set_buffer _fforms_target_buffer)
      (raise_anchor)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: __forms_add
;**    ARGUMENTS: see dialog manager interface
;**
;**  DESCRIPTION: action macro for _forms_add.  Unlike the __forms_menu,
;**               this action macro does all the work.
;**
;**      RETURNS: TRUE (usually)
;**        NOTES:
;**
;***********************************************************************
(macro __forms_add
   (
      (int  event_type line_no retval )
      (string  button_text )

      (get_parm 0 event_type)
      (get_parm 1 line_no)
      (get_parm 2 button_text)
      (= retval TRUE)
      (switch  event_type
         DIALOG_EXIT_LIST
         (
            (if (== line_no 3) (= new_form_align button_text))
         )
         DIALOG_EXIT_FIELD
         (
            (if (== line_no 1)
               (
                  (if (!= 1 (strlen button_text))
                     (
                        (error "Form ID must be a single character")
                        (= retval FALSE)
                     )
                  ;else
                     (
                        (if (search_string button_text _pform NULL REGXPR_ON CASE_INSENSITIVE)
                           (
                              (error "Form ID already in use")
                              (= retval FALSE)
                           )
                        ;else
                           (= new_form_id button_text)
                        )
                     )
                  )
               )
            )
            (if (== line_no 2) (= new_form_name button_text))
         )
         DIALOG_ESCAPE
         (
            (= new_form_id "")
         )
      )
      (returns retval)
   )
)


;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _get_cursor_word
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: returns the "word" at the cursor
;**
;**      RETURNS:
;**        NOTES:
;**
;***********************************************************************
(macro _get_cursor_word
   (
      (int     row col orow ocol count obuffer scol)
      (string  cursor_word valid_chars char)

      (= obuffer (inq_buffer))
      (set_buffer _fforms_target_buffer)
      (inq_position orow ocol)

      (= valid_chars "_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890")
      (inq_position row col)
      (if (!= col 1)
         (
            (search_back "[~A-Za-z0-9_]")
            (inq_position NULL scol)
            (if (!= col scol)
               (
                  (next_char)
                  (++ scol)
               )
            )
         )
      )
      (if (== 0 (index valid_chars (= char (read 1))))
         (
            (returns "")
         )
      ;else
            (
            (while (index valid_chars (= char (read 1)))
               (
                  (++ count)
                  (right)
               )
            )

            (move_abs row scol)
            (= cursor_word (read count))
            (returns cursor_word)
         )
      )
      (move_abs orow ocol)
      (set_buffer obuffer)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _move_to_working_buffer
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: move form to a separate buffer for work area
;**               The current position in the forms buffer
;**                  is the "options" line
;**               The form must end with a line containing !end
;**
;**      RETURNS: buffer ID of new buffer
;**
;***********************************************************************
(macro _move_to_working_buffer
   (
      (int  obuffer)

      (= obuffer (inq_buffer))
      (= _fforms_work_buffer (create_buffer "FORMS_WORK" NULL SYSTEM))
      (set_buffer _fforms_source_buffer)
      (save_position)
      (beginning_of_line)
      (down)
      (drop_anchor LINE_MARK)
      (if (search_fwd "!end")
         (
            (up)
            (copy)
            (set_buffer _fforms_work_buffer)
            (paste)
            (returns YES)
         )
      ;else
         (
            (error "!end not found")
            (returns NO)
            (raise_anchor)
         )
      )
      (restore_position)
      (set_buffer obuffer)
   )
)



;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _find_form
;**    ARGUMENTS: form ID
;**
;**  DESCRIPTION: find a form matching the ID in the forms file
;**
;**      RETURNS: TRUE if found, FALSE if not
;**               if found, current position in buffer is the form
;**
;***********************************************************************
(macro _find_form
   (
      (int     key found obuffer)
      (string  searcher)

      (= obuffer (inq_buffer))
      (get_parm 0 key)
;**
;**     get extension and character identifier for search
;**
      (sprintf searcher "!%c.{%s}|{\\*}[ \t\n*]+" key _fforms_ext)
;**
;**     go to top of forms buffer, search (case insensitive) for identifier
;**
      (set_buffer _fforms_source_buffer)
      (top_of_buffer)
      (= found (search_fwd searcher REGXPR_ON CASE_INSENSITIVE))
      (returns (> found 0))
      (set_buffer obuffer)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _get_option
;**    ARGUMENTS: string option_name
;**
;**  DESCRIPTION: gets the value string for any forms option.  Forms
;**               options take the form:
;**                  !<option name>: <value string>
;**
;**      RETURNS: value string
;**        NOTES:
;**
;***********************************************************************
(macro _get_option
   (
      (string  option_name optype line option_value )
      (int     start length obuffer )

      (= obuffer (inq_buffer))
      (set_buffer _fforms_source_buffer)
      (get_parm 0 option_name)
      (sprintf optype "!%s:\\c*[!\n]" option_name)
      (save_position)
      (beginning_of_line)
      (= line (read))
      (= start (search_string optype line length REGXPR_ON CASE_INSENSITIVE))
      (if (!= start 0)
         (
            (= option_value (substr line start (- length 1)))
            (returns (trim (ltrim option_value)))
         )
         ;else
         (
            (returns "")
         )
      )
      (restore_position)
      (set_buffer obuffer)
   )
)

;*************************************** AUTHOR:  G. Belfor ************
;**
;** ROUTINE NAME: _scrap_mgmt
;**    ARGUMENTS: 0 to save, 1 to restore
;**
;**  DESCRIPTION: save the contents of the scrap buffer
;**
;**      RETURNS: none
;**        NOTES:
;**
;***********************************************************************
(macro _scrap_mgmt
   (
      (int  op obuffer)

      (get_parm 0 op)
      (= obuffer (inq_buffer))
      (if (== op SAVE)
         (
            (= _fforms_scrap_save (create_buffer "FSCRAP_SAVE" NULL SYSTEM))
            (set_buffer _fforms_scrap_save)
            (inq_scrap _fforms_scrap_nl _fforms_scrap_type)
            (paste)
         )
         ;else
         (
            (set_buffer _fforms_scrap_save)
            (top_of_buffer)
            (drop_anchor)
            (end_of_buffer)
            (copy)
            (set_scrap_info _fforms_scrap_nl _fforms_scrap_type)
            (delete_buffer _fforms_scrap_save)
         )
      )
      (set_buffer obuffer)
   )
)

;*************************************** AUTHOR: G. Belfor       *******
;**
;** ROUTINE NAME: _get_forms_id
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: wait for a key...
;**      If its a TAB, show the menu, then process the key selected
;**      If it is the HELP key, show the help
;**
;**      RETURNS: form ID selected, zero if invalid
;**        NOTES:
;**
;***********************************************************************
(macro _get_forms_id
   (
      (int  key)

      (while 1
         (
            (message "Form ID? (press TAB for menu)")
            (while (! (inq_kbd_char)))
            (= key (read_char))
            (if (== 0 (& key 0xff))
               (
                  (if (== "<Alt-h>" (int_to_key key))
                     (display_help "forms" "forms.hlp")
                  ;else
                     (return 0)
                  )
               )
            ;else
               (break)
            )
         )
      )
      (= key (& key 0xff))
      (if (== key TAB)
         (
            (_forms_menu)
            (= key (& (read_char) 0xff))
         )
      )
      (return key)
   )
)



;*************************************** AUTHOR: G. Belfor       *******
;**
;** ROUTINE NAME: write_buffer
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: replacement for write_buffer...allows the forms
;**               buffer to remain resident until the user tries to
;**               write out a new copy
;**
;**      RETURNS: none
;**        NOTES: Unfortunately, the full file name of the forms file
;**               and the filename of the current buffer may mean the
;**               same thing, but contain different slashes (like
;**               c:\brief\forms and c:/brief/forms).  The slashes
;**               are all converted to backslashes
;**
;***********************************************************************
(replacement write_buffer
   (
      (string fname)

      (inq_names fname)
      (= fname (_fslash_to_bslash (lower fname)))
      (if (&& (== fname _fforms_file) (!= _fforms_source_buffer 0))
         (
            (delete_buffer _fforms_source_buffer)
            (= _fforms_source_buffer 0)
         )
      )
      (write_buffer)
   )
)


;*************************************** AUTHOR: G. Belfor       *******
;**
;** ROUTINE NAME: _ff_cleanup
;**    ARGUMENTS: none
;**
;**  DESCRIPTION: Perform cleanup before exit...
;**                  if the DELETE_SOURCE flag is set, delete the
;**                  forms buffer.  Also turn pausing on errors back
;**                  to old value
;**
;***********************************************************************
(macro _ff_cleanup
   (
      (if ( && DELETE_SOURCE (!= _fforms_source_buffer 0))
         (
            (delete_buffer _fforms_source_buffer)
            (= _fforms_source_buffer 0)
         )
      )
      (pause_on_error _fforms_pause_save)
   )
)


;**@H*********************************** AUTHOR: G. Belfor       *******
;**
;**   MACRO NAME: _fslash_to_bslash
;**    ARGUMENTS: string filepath
;**
;**  DESCRIPTION: converts all forward slashes to back slashes in a
;**               filepath
;**
;**      RETURNS: converted string
;**        NOTES:
;**
;********************************************************************@H*
(macro _fslash_to_bslash
   (
        (int        loc)
        (string    str)

        (get_parm 0 str)
        (while (= loc (index str "/"))
            (= str (+ (+ (substr str 1 (- loc 1)) "\\") (substr str (+ loc 1))))
        )
        (returns str)
    )
)